(module type-sugar mzscheme
  (require "types.scm")
  (require (lib "plt-match.ss"))

  ;; Use syntax-case to pull apart a syntax object representing a type
  (define (parse-type stx)
    (syntax-case stx ()
      (()
       (list))
      ((tycon args ...)
       (let ((symb (syntax-e #'tycon)))
         (if (equal? 'quote symb)
             (let ((id (syntax-e (car (syntax->list #'(args ...))))))
                   (make-ty-var id))
             (let* ((arglist (syntax->list #'(args ...)))
                    (tycon-ans (symbol-to-tycon symb))
                    (argtys (map parse-type arglist)))
               (cond
                 ((not tycon-ans) (cons (parse-type #'tycon) argtys))
                 ((valid-arity tycon-ans (length arglist)) (make-ty-app tycon-ans argtys))
                 ((valid-arity tycon-ans 0) (cons (parse-type #'tycon) argtys))
                 (else (raise-syntax-error #f "Tycon used with incorrect number of args" 
                                           stx #'tycon)))))))
      (tycon
       (let ((tycon-ans (symbol-to-tycon (syntax-e #'tycon))))
         (cond
           ((not tycon-ans) (raise-syntax-error #f "Unrecognized tycon" stx #'tycon))
           ((valid-arity tycon-ans 0) (make-ty-app tycon-ans ()))
           (else (raise-syntax-error #f "Tycon expects arguments" stx #'tycon)))))))
  
  ;; Take a type that has been read in and convert it to normal form
  ;; This replaces the lists that appear as arguments to arrows into
  ;; tycons
  (define (normalize-type type)
    (match type
      ((struct ty-app (tycon args))
       (make-ty-app tycon
        (normalize-tycon tycon (map normalize-type args))))
      ((? list? types) (map normalize-type types))
      (_ type)))
  
  ;; Convert a list of types to a 'list' using tycons-cons and tycons-null.  This
  ;; allows for the bone-simple unification algorithm to work.  Need to special
  ;; case the times when the user specifies the arguments
  (define (normalize-ty-vector-helper vector ans)
    (if (null? vector)
        ans
        (normalize-ty-vector-helper (cdr vector)
          (make-ty-app (make-tycon-cons) 
                       (list (normalize-type (car vector)) ans)))))
  (define (normalize-ty-vector vector fresh-var)
    (cond
      ((null? vector) fresh-var)
      ((not (list? vector))
       (normalize-ty-vector (list vector) fresh-var))
      ((or (and (ty-app? (car vector))
                (tycon-null? (ty-app-tycon (car vector))))
           (and (ty-var? (car vector))
                (char-upper-case? (string-ref 
                                   (symbol->string 
                                    (ty-var-identifier (car vector))) 0))))
       (normalize-ty-vector-helper (cdr vector) (car vector)))           
      (else
       (normalize-ty-vector-helper vector fresh-var))))
       
  (define (normalize-arrow args result)
    (let ((stack-var   (fresh-tystackvar)))
      (list (normalize-ty-vector args stack-var)
            (normalize-ty-vector result stack-var))))
  (define (normalize-tycon tycon args)
    (match tycon
      ((struct tycon-pure-arrow ())   (apply normalize-arrow args))
      ((struct tycon-impure-arrow ()) (apply normalize-arrow args))
      (_ args)))
  
  ;; This function parses and returns the normalized version of the given type
  (define (type-sugar stx)
    (normalize-type (parse-type stx)))
 
  (provide type-sugar parse-type))